home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Plus 1995 #5 & #6
/
Amiga Plus CD - 1995 - No. 5 and 6.iso
/
pd
/
serien
/
purity
/
nr.13
/
kickpascal-programme
/
amigapascal
/
amigapascal.p
< prev
next >
Wrap
Text File
|
1995-04-22
|
9KB
|
476 lines
PROGRAM Amiga_Pascal_Compiler;
CONST programm = 0;
variable = 1;
beginn = 2;
ende = 3;
whiled = 4;
dow = 5;
print = 6;
comma = 7;
equal = 8;
plus = 9;
minus = 10;
identi = 11;
konstante = 12;
eofi = 13;
cr = 14;
mulu = 15;
divu = 16;
maxidlen = 79;
version = "$VER: Amiga-Pascal-Compiler 1.0 (18.02.93)";
TYPE Identifier = STRING[maxIDlen+1];
VAR source,destination : FILE OF CHAR;
chara : CHAR;
sym : BYTE;
ident : Identifier;
constant : LONGINT;
labels : INTEGER;
zeile,e : INTEGER;
errtxt,fname,fname2,extx : STRING[50];
c : CHAR;
PROCEDURE GetChar(VAR chara: CHAR);
BEGIN
READ(source,chara);
IF chara=CHR(10) THEN INC(Zeile);
END;
PROCEDURE GetSym(VAR sym: BYTE);
VAR i: INTEGER;
BEGIN
GetChar(chara);
WHILE chara IN [0..9,11..32] DO GetChar(chara);
ident:="";
CASE chara OF
CHR(10): sym:=cr;
'a'..'z',
'A'..'Z': BEGIN
i:=1;
WHILE (i<=maxIDlen) AND (UPCASE(chara)>='A') AND (UPCASE(chara)<='Z') DO
BEGIN
ident:=ident+chara;
GetChar(chara);
INC(i);
END;
IF ident = "PROGRAM" THEN sym:=programm
ELSE IF ident = "VAR" THEN sym:=variable
ELSE IF ident = "BEGIN" THEN sym:=beginn
ELSE IF ident = "END" THEN sym:=ende
ELSE IF ident = "WHILE" THEN sym:=whiled
ELSE IF ident = "DO" THEN sym:=dow
ELSE IF ident = "WRITELN" THEN sym:=print
ELSE sym:=identi;
END;
'0'..'9': BEGIN
constant:=0;
WHILE chara IN ['0'..'9'] DO
BEGIN
constant:=10*constant+ORD(chara)-ORD('0');
GetChar(chara);
END;
sym:=konstante;
END;
':': BEGIN
GetChar(chara);
IF chara="=" THEN sym:=equal;
END;
',': sym:=comma;
'+': sym:=plus
'-': sym:=minus;
'*': sym:=mulu;
'/': sym:=divu;
OTHERWISE BEGIN
errtxt:='Unexpected symbol in line '+INTSTR(zeile);
ERROR(errtxt);
END;
END;
END;
PROCEDURE W(s: STR);
BEGIN
WRITE(destination,s);
END;
PROCEDURE WL(s: STR);
BEGIN
WRITELN(destination,s);
END;
PROCEDURE DCL(vari: STR);
BEGIN
W(vari);
WL(": dc.l 0");
END;
PROCEDURE MOVEvarD0(vari: STR);
BEGIN
W(" MOVE.L ");
W(vari);
WL(",D0");
END;
PROCEDURE MOVEconstD0(c: LONGINT);
VAR numm: STRING[5];
BEGIN
W(" MOVE.L #");
numm:=INTSTR(c);
W(numm);
WL(",D0");
END;
PROCEDURE MOVED0var(name: PTR);
BEGIN
W(" MOVE.L D0,");
WL(name);
END;
PROCEDURE MOVED1var(name: PTR);
BEGIN
W(" MOVE.L D1,");
WL(name);
END;
PROCEDURE MOVED0D1;
BEGIN
WL(" MOVE.L D0,D1");
END;
PROCEDURE ADDD1D0;
BEGIN
WL(" ADD.L D1,D0");
END;
PROCEDURE MULSD1D0;
BEGIN
WL(" MULS.L D1,D0");
END;
PROCEDURE DIVSD1D0;
BEGIN
WL(" DIVS.L D0,D1");
END;
PROCEDURE NEGD0;
BEGIN
WL(" NEG.L D0");
END;
PROCEDURE TSTD0;
BEGIN
WL(" TST.L D0");
END;
FUNCTION GetLabel(VAR labels: INTEGER): INTEGER;
BEGIN
INC(labels);
GetLabel:=labels;
END;
PROCEDURE mlabel(l: INTEGER);
VAR numm: STRING[5];
BEGIN
W("L");
numm:=INTSTR(l);
W(numm);
WL(":");
END;
PROCEDURE Ble(l: INTEGER);
VAR numm: STRING[5];
BEGIN
W(" BLE L");
numm:=INTSTR(l);
WL(numm);
END;
PROCEDURE BRA(l: INTEGER);
VAR numm: STRING[5];
BEGIN
W(" BRA L");
numm:=INTSTR(l);
WL(numm);
END;
PROCEDURE PrintD0;
BEGIN
WL(" LEA _format,A0");
WL(" MOVE.L A0,D1" );
WL(" LEA _print,A0" );
WL(" MOVE.L A0,D2" );
WL(" MOVE.L D0,(A0)" );
WL(" MOVE.L _dos,A6" );
WL(" JSR -954(A6)" );
END;
PROCEDURE StartUp(Start: INTEGER);
BEGIN
WL("_dos: DC.L 0" );
WL("_dosname: DC.B 'dos.library',0");
WL("_format: DC.B '%ld',10,0" );
WL(" DS.L 0" );
WL("_print: DC.L 0" );
mlabel(start);
WL(" LEA _dosname,A1" );
WL(" MOVE.L #37,D0" );
WL(" MOVE.L $4,A6" );
WL(" JSR -552(A6)" );
WL(" TST.L D0" );
WL(" BNE.S ok_" );
WL(" RTS" );
WL("ok_:" );
WL(" MOVE.L D0,_dos" );
END;
PROCEDURE CleanUp;
BEGIN
WL(" MOVE.L _dos,A1" );
WL(" MOVE.L $4,A6" );
WL(" JSR -414(A6)");
WL(" MOVE.L #0,D0" );
WL(" RTS" );
WL(" END" );
END;
{Parser;}
PROCEDURE Check(symm: BYTE; msg: STR);
BEGIN
IF sym=symm THEN GetSym(Sym)
ELSE
BEGIN
errtxt:=msg+" IN ZEILE "+INTSTR(zeile);
ERROR(errtxt);
END;
END;
PROCEDURE VarDeclaration;
BEGIN
GetSym(sym);
WHILE sym=identi DO
BEGIN
IF sym<>identi THEN
BEGIN
errtxt:='Identifier expected in line '+INTSTR(zeile)+'!';
ERROR(errtxt);
END;
DCL(Ident);
GetSym(Sym);
END;
GetSym(Sym);
END;
PROCEDURE Factor;
BEGIN
CASE Sym OF
identi: BEGIN
MOVEvarD0(ident);
GetSym(Sym);
END;
konstante: BEGIN
MOVEconstD0(constant);
GetSym(sym);
END;
OTHERWISE BEGIN
errtxt:='Factor expected in line '+INTSTR(zeile)+'!';
ERROR(errtxt);
END;
END;
END;
FUNCTION Expression: BOOLEAN;
VAR neg,flag: BOOLEAN;
BEGIN
flag:=FALSE;
neg:=FALSE;
IF sym IN [plus,minus] THEN neg:=sym=minus;
Factor;
IF neg THEN NEGD0;
WHILE sym IN [plus,minus] DO
BEGIN
neg:=sym=minus;
GetSym(Sym);
MOVED0D1;
Factor;
IF neg THEN NEGD0;
ADDD1D0;
END;
WHILE sym=mulu DO
BEGIN
GetSym(sym);
MOVED0D1;
Factor;
MULSD1D0;
END;
WHILE sym=divu DO
BEGIN
flag:=TRUE;
GetSym(sym);
MOVED0D1;
Factor;
DIVSD1D0;
END;
Expression:=flag
END;
PROCEDURE Statement;
VAR start,ent: INTEGER;
varname : STRING[maxIDlen];
boob : BOOLEAN;
BEGIN
CASE sym OF
identi: BEGIN
varname:=ident;
GetSym(sym);
Check(equal,"':=' expected!");
IF Expression THEN MOVED1Var(^varname)
ELSE MOVED0var(^varname);
END;
whiled: BEGIN
GetSym(sym);
start:=GetLabel(labels);
ent:=GetLabel(labels);
mlabel(start);
boob:=Expression;
Check(dow,"DO expected!");
TSTD0;
BLE(ent);
Check(beginn,"BEGIN expected!");
WHILE sym<>ende DO Statement;
BRA(start);
mlabel(ent);
END;
print: BEGIN
GetSym(sym);
boob:=Expression;
PrintD0;
END;
OTHERWISE BEGIN
errtxt:="Statement expected in line "+INTSTR(zeile)+'!';
ERROR(errtxt);
END;
END;
END;
PROCEDURE Programkopf;
VAR start: INTEGER;
BEGIN
GetSym(sym);
Check(programm,"PROGRAM expected!");
Check(identi,"Name expected");
start:=GetLabel(labels);
BRA(start);
GetSym(sym);
IF sym=variable THEN VarDeclaration;
Check(beginn,"BEGIN expected!");
StartUp(start);
WHILE sym<>ende DO Statement;
CleanUp;
Check(ende,"END expected!");
END;
FUNCTION GetName: STR;
VAR s : STRING[80];
i,j: INTEGER;
name: STRING[80];
BEGIN
IF parameterlen>=80 THEN
Name:=''
ELSE
BEGIN
s:=parameterstr;
s[parameterlen+1]:=CHR(0);
i:=1;
WHILE (s[i]=' ') DO INC(i);
j:=1;
WHILE s[i]>' ' DO
BEGIN
name[j]:=s[i];
INC(i);
INC(j)
END;
name[j]:=CHR(0)
END;
GetName:=name;
END;
BEGIN
IF NOT FromWB THEN
BEGIN
labels:=0;
Zeile:=1;
fname:=GetName;
IF (fname<>"") AND (fname<>"?") THEN
BEGIN
RESET(source,fname);
IF ioResult=0 THEN
BEGIN
fname2:=fname+".s";
REWRITE(destination,fname2);
IF ioResult=0 THEN
BEGIN
WRITE('Compiling...');
ProgramKopf;
ParameterLen:=0;
CLOSE(destination);
CLOSE(source);
WRITELN('Finished.');
WRITELN('Please compile with a68k and link it with BLink');
WRITELN('Please type: '\e'32ma68k ',fname,'.s');
WRITELN(' blink ',fname,'.o TO ',fname,'.exe'\e'31m');
END
ELSE WRITELN("Couldn't open output file! (",fname2,")");
END
ELSE WRITELN("Couldn't open input file! (",fname,")");
END
ELSE
BEGIN
WRITELN(""\e"32mAmiga-Pascal-Compiler 1.0"\e"31m by Danny Amor (18.02.93)");
WRITELN("Written in Kick-"\e"32mPascal"\e"31m 2.12");
WRITELN("For further information read the doc-file");
WRITELN("Usage: Compile <source file>");
END;
END;
END;